home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / f2c-9510.000 / f2c-9510 / f2c-951007-libs-1.1 / src / proc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-10-07  |  37.5 KB  |  1,806 lines
  1. /****************************************************************
  2. Copyright 1990, 1994, 1995 by AT&T Bell Laboratories and Bellcore.
  3.  
  4. Permission to use, copy, modify, and distribute this software
  5. and its documentation for any purpose and without fee is hereby
  6. granted, provided that the above copyright notice appear in all
  7. copies and that both that the copyright notice and this
  8. permission notice and warranty disclaimer appear in supporting
  9. documentation, and that the names of AT&T Bell Laboratories or
  10. Bellcore or any of their entities not be used in advertising or
  11. publicity pertaining to distribution of the software without
  12. specific, written prior permission.
  13.  
  14. AT&T and Bellcore disclaim all warranties with regard to this
  15. software, including all implied warranties of merchantability
  16. and fitness.  In no event shall AT&T or Bellcore be liable for
  17. any special, indirect or consequential damages or any damages
  18. whatsoever resulting from loss of use, data or profits, whether
  19. in an action of contract, negligence or other tortious action,
  20. arising out of or in connection with the use or performance of
  21. this software.
  22. ****************************************************************/
  23.  
  24. #include "defs.h"
  25. #include "names.h"
  26. #include "output.h"
  27. #include "p1defs.h"
  28.  
  29. /* round a up to the nearest multiple of b:
  30.  
  31.    a = b * floor ( (a + (b - 1)) / b )*/
  32.  
  33. #undef roundup
  34. #define roundup(a,b)    ( b * ( (a+b-1)/b) )
  35.  
  36. #define EXNULL (union Expression *)0
  37.  
  38. static void dobss Argdcl((void));
  39. static void docomleng Argdcl((void));
  40. static void docommon Argdcl((void));
  41. static void doentry Argdcl((struct Entrypoint*));
  42. static void epicode Argdcl((void));
  43. static int nextarg Argdcl((int));
  44. static void retval Argdcl((int));
  45.  
  46. static char Blank[] = BLANKCOMMON;
  47.  
  48.  static char *postfix[] = { "g", "h", "i",
  49. #ifdef TYQUAD
  50.                     "j",
  51. #endif
  52.                     "r", "d", "c", "z", "g", "h", "i" };
  53.  
  54.  chainp new_procs;
  55.  int prev_proc, proc_argchanges, proc_protochanges;
  56.  
  57.  void
  58. #ifdef KR_headers
  59. changedtype(q)
  60.     Namep q;
  61. #else
  62. changedtype(Namep q)
  63. #endif
  64. {
  65.     char buf[200];
  66.     int qtype, type1;
  67.     register Extsym *e;
  68.     Argtypes *at;
  69.  
  70.     if (q->vtypewarned)
  71.         return;
  72.     q->vtypewarned = 1;
  73.     qtype = q->vtype;
  74.     e = &extsymtab[q->vardesc.varno];
  75.     if (!(at = e->arginfo)) {
  76.         if (!e->exused)
  77.             return;
  78.         }
  79.     else if (at->changes & 2 && qtype != TYUNKNOWN && !at->defined)
  80.         proc_protochanges++;
  81.     type1 = e->extype;
  82.     if (type1 == TYUNKNOWN)
  83.         return;
  84.     if (qtype == TYUNKNOWN)
  85.         /* e.g.,
  86.             subroutine foo
  87.             end
  88.             external foo
  89.             call goo(foo)
  90.             end
  91.         */
  92.         return;
  93.     sprintf(buf, "%.90s: inconsistent declarations:\n\
  94.     here %s%s, previously %s%s.", q->fvarname, ftn_types[qtype],
  95.         qtype == TYSUBR ? "" : " function",
  96.         ftn_types[type1], type1 == TYSUBR ? "" : " function");
  97.     warn(buf);
  98.     }
  99.  
  100.  void
  101. #ifdef KR_headers
  102. unamstring(q, s)
  103.     register Addrp q;
  104.     register char *s;
  105. #else
  106. unamstring(register Addrp q, register char *s)
  107. #endif
  108. {
  109.     register int k;
  110.     register char *t;
  111.  
  112.     k = strlen(s);
  113.     if (k < IDENT_LEN) {
  114.         q->uname_tag = UNAM_IDENT;
  115.         t = q->user.ident;
  116.         }
  117.     else {
  118.         q->uname_tag = UNAM_CHARP;
  119.         q->user.Charp = t = mem(k+1, 0);
  120.         }
  121.     strcpy(t, s);
  122.     }
  123.  
  124.  static void
  125. fix_entry_returns(Void)    /* for multiple entry points */
  126. {
  127.     Addrp a;
  128.     int i;
  129.     struct Entrypoint *e;
  130.     Namep np;
  131.  
  132.     e = entries = (struct Entrypoint *)revchain((chainp)entries);
  133.     allargs = revchain(allargs);
  134.     if (!multitype)
  135.         return;
  136.  
  137.     /* TYLOGICAL should have been turned into TYLONG or TYSHORT by now */
  138.  
  139.     for(i = TYINT1; i <= TYLOGICAL; i++)
  140.         if (a = xretslot[i])
  141.             sprintf(a->user.ident, "(*ret_val).%s",
  142.                 postfix[i-TYINT1]);
  143.  
  144.     do {
  145.         np = e->enamep;
  146.         switch(np->vtype) {
  147.             case TYINT1:
  148.             case TYSHORT:
  149.             case TYLONG:
  150. #ifdef TYQUAD
  151.             case TYQUAD:
  152. #endif
  153.             case TYREAL:
  154.             case TYDREAL:
  155.             case TYCOMPLEX:
  156.             case TYDCOMPLEX:
  157.             case TYLOGICAL1:
  158.             case TYLOGICAL2:
  159.             case TYLOGICAL:
  160.                 np->vstg = STGARG;
  161.             }
  162.         }
  163.         while(e = e->entnextp);
  164.     }
  165.  
  166.  static void
  167. #ifdef KR_headers
  168. putentries(outfile)
  169.     FILE *outfile;
  170. #else
  171. putentries(FILE *outfile)
  172. #endif
  173.     /* put out wrappers for multiple entries */
  174. {
  175.     char base[IDENT_LEN];
  176.     struct Entrypoint *e;
  177.     Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np;
  178.     chainp args, lengths;
  179.     int i, k, mt, nL, t, type;
  180.     extern char *dfltarg[], **dfltproc;
  181.  
  182.     e = entries;
  183.     if (!e->enamep) /* only possible with erroneous input */
  184.         return;
  185.     nL = (nallargs + nallchargs) * sizeof(Namep *);
  186.     A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **));
  187.     Ae = A + nallargs;
  188.     Alp = (Namep **)(Ae1 = Ae + nallchargs);
  189.     i = k = 0;
  190.     for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) {
  191.         np = (Namep)args->datap;
  192.         if (np->vtype == TYCHAR && np->vclass != CLPROC)
  193.             *a1 = &Ae[i++];
  194.         }
  195.  
  196.     mt = multitype;
  197.     multitype = 0;
  198.     sprintf(base, "%s0_", e->enamep->cvarname);
  199.     do {
  200.         np = e->enamep;
  201.         lengths = length_comp(e, 0);
  202.         proctype = type = np->vtype;
  203.         if (protofile)
  204.             protowrite(protofile, type, np->cvarname, e, lengths);
  205.         nice_printf(outfile, "\n%s ", c_type_decl(type, 1));
  206.         nice_printf(outfile, "%s", np->cvarname);
  207.         if (!Ansi) {
  208.             listargs(outfile, e, 0, lengths);
  209.             nice_printf(outfile, "\n");
  210.             }
  211.             list_arg_types(outfile, e, lengths, 0, "\n");
  212.         nice_printf(outfile, "{\n");
  213.         frchain(&lengths);
  214.         next_tab(outfile);
  215.         if (mt)
  216.             nice_printf(outfile,
  217.                 "Multitype ret_val;\n%s(%d, &ret_val",
  218.                 base, k); /*)*/
  219.         else if (ISCOMPLEX(type))
  220.             nice_printf(outfile, "%s(%d,%s", base, k,
  221.                 xretslot[type]->user.ident); /*)*/
  222.         else if (type == TYCHAR)
  223.             nice_printf(outfile,
  224.                 "%s(%d, ret_val, ret_val_len", base, k); /*)*/
  225.         else
  226.             nice_printf(outfile, "return %s(%d", base, k); /*)*/
  227.         k++;
  228.         memset((char *)A, 0, nL);
  229.         for(args = e->arglist; args; args = args->nextp) {
  230.             np = (Namep)args->datap;
  231.             A[np->argno] = np;
  232.             if (np->vtype == TYCHAR && np->vclass != CLPROC)
  233.                 *Alp[np->argno] = np;
  234.             }
  235.         args = allargs;
  236.         for(a = A; a < Ae; a++, args = args->nextp) {
  237.             t = ((Namep)args->datap)->vtype;
  238.             nice_printf(outfile, ", %s", (np = *a)
  239.                 ? np->cvarname
  240.                 : ((Namep)args->datap)->vclass == CLPROC
  241.                 ? dfltproc[((Namep)args->datap)->vimpltype
  242.                     ? (Castargs ? TYUNKNOWN : TYSUBR)
  243.                     : t == TYREAL && forcedouble && !Castargs
  244.                     ? TYDREAL : t]
  245.                 : dfltarg[((Namep)args->datap)->vtype]);
  246.             }
  247.         for(; a < Ae1; a++)
  248.             if (np = *a)
  249.                 nice_printf(outfile, ", %s_len", np->fvarname);
  250.             else
  251.                 nice_printf(outfile, ", (ftnint)0");
  252.         nice_printf(outfile, /*(*/ ");\n");
  253.         if (mt) {
  254.             if (type == TYCOMPLEX)
  255.                 nice_printf(outfile,
  256.             "r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\n");
  257.             else if (type == TYDCOMPLEX)
  258.                 nice_printf(outfile,
  259.             "r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\n");
  260.             else if (type <= TYLOGICAL)
  261.                 nice_printf(outfile, "return ret_val.%s;\n",
  262.                     postfix[type-TYINT1]);
  263.             }
  264.         nice_printf(outfile, "}\n");
  265.         prev_tab(outfile);
  266.         }
  267.         while(e = e->entnextp);
  268.     free((char *)A);
  269.     }
  270.  
  271.  static void
  272. #ifdef KR_headers
  273. entry_goto(outfile)
  274.     FILE *outfile;
  275. #else
  276. entry_goto(FILE *outfile)
  277. #endif
  278. {
  279.     struct Entrypoint *e = entries;
  280.     int k = 0;
  281.  
  282.     nice_printf(outfile, "switch(n__) {\n");
  283.     next_tab(outfile);
  284.     while(e = e->entnextp)
  285.         nice_printf(outfile, "case %d: goto %s;\n", ++k,
  286.             user_label((long)(extsymtab - e->entryname - 1)));
  287.     nice_printf(outfile, "}\n\n");
  288.     prev_tab(outfile);
  289.     }
  290.  
  291. /* start a new procedure */
  292.  
  293.  void
  294. newproc(Void)
  295. {
  296.     if(parstate != OUTSIDE)
  297.     {
  298.         execerr("missing end statement", CNULL);
  299.         endproc();
  300.     }
  301.  
  302.     parstate = INSIDE;
  303.     procclass = CLMAIN;    /* default */
  304. }
  305.  
  306.  static void
  307. zap_changes(Void)
  308. {
  309.     register chainp cp;
  310.     register Argtypes *at;
  311.  
  312.     /* arrange to get correct count of prototypes that would
  313.        change by running f2c again */
  314.  
  315.     if (prev_proc && proc_argchanges)
  316.         proc_protochanges++;
  317.     prev_proc = proc_argchanges = 0;
  318.     for(cp = new_procs; cp; cp = cp->nextp)
  319.         if (at = ((Namep)cp->datap)->arginfo)
  320.             at->changes &= ~1;
  321.     frchain(&new_procs);
  322.     }
  323.  
  324. /* end of procedure. generate variables, epilogs, and prologs */
  325.  
  326.  void
  327. endproc(Void)
  328. {
  329.     struct Labelblock *lp;
  330.     Extsym *ext;
  331.  
  332.     if(parstate < INDATA)
  333.         enddcl();
  334.     if(ctlstack >= ctls)
  335.         err("DO loop or BLOCK IF not closed");
  336.     for(lp = labeltab ; lp < labtabend ; ++lp)
  337.         if(lp->stateno!=0 && lp->labdefined==NO)
  338.             errstr("missing statement label %s",
  339.                 convic(lp->stateno) );
  340.  
  341. /* Save copies of the common variables in extptr -> allextp */
  342.  
  343.     for (ext = extsymtab; ext < nextext; ext++)
  344.         if (ext -> extstg == STGCOMMON && ext -> extp) {
  345.             extern int usedefsforcommon;
  346.  
  347. /* Write out the abbreviations for common block reference */
  348.  
  349.             copy_data (ext -> extp);
  350.             if (usedefsforcommon) {
  351.                 wr_abbrevs (c_file, 1, ext -> extp);
  352.                 ext -> used_here = 1;
  353.                 }
  354.             else
  355.                 ext -> extp = CHNULL;
  356.  
  357.             }
  358.  
  359.     if (nentry > 1)
  360.         fix_entry_returns();
  361.     epicode();
  362.     donmlist();
  363.     dobss();
  364.     start_formatting ();
  365.     if (nentry > 1)
  366.         putentries(c_file);
  367.  
  368.     zap_changes();
  369.     procinit();    /* clean up for next procedure */
  370. }
  371.  
  372.  
  373.  
  374. /* End of declaration section of procedure.  Allocate storage. */
  375.  
  376.  void
  377. enddcl(Void)
  378. {
  379.     register struct Entrypoint *ep;
  380.     struct Entrypoint *ep0;
  381.     chainp cp;
  382.     extern char *err_proc;
  383.     static char comblks[] = "common blocks";
  384.  
  385.     err_proc = comblks;
  386.     docommon();
  387.  
  388. /* Now the hash table entries for fields of common blocks have STGCOMMON,
  389.    vdcldone, voffset, and varno.  And the common blocks themselves have
  390.    their full sizes in extleng. */
  391.  
  392.     err_proc = "equivalences";
  393.     doequiv();
  394.  
  395.     err_proc = comblks;
  396.     docomleng();
  397.  
  398. /* This implies that entry points in the declarations are buffered in
  399.    entries   but not written out */
  400.  
  401.     err_proc = "entries";
  402.     if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) {
  403.         /* entries could be 0 in case of an error */
  404.         do doentry(ep);
  405.             while(ep = ep->entnextp);
  406.         entries = (struct Entrypoint *)revchain((chainp)ep0);
  407.         }
  408.  
  409.     err_proc = 0;
  410.     parstate = INEXEC;
  411.     p1put(P1_PROCODE);
  412.     freetemps();
  413.     if (earlylabs) {
  414.         for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp)
  415.             p1_label((long)cp->datap);
  416.         frchain(&earlylabs);
  417.         }
  418.     p1_line_number(lineno); /* for files that start with a MAIN program */
  419.                 /* that starts with an executable statement */
  420. }
  421.  
  422. /* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
  423.  
  424. /* Main program or Block data */
  425.  
  426.  void
  427. #ifdef KR_headers
  428. startproc(progname, class)
  429.     Extsym *progname;
  430.     int class;
  431. #else
  432. startproc(Extsym *progname, int class)
  433. #endif
  434. {
  435.     register struct Entrypoint *p;
  436.  
  437.     p = ALLOC(Entrypoint);
  438.     if(class == CLMAIN) {
  439.         puthead(CNULL, CLMAIN);
  440.         if (progname)
  441.             strcpy (main_alias, progname->cextname);
  442.     } else
  443.         puthead(CNULL, CLBLOCK);
  444.     if(class == CLMAIN)
  445.         newentry( mkname(" MAIN"), 0 )->extinit = 1;
  446.     p->entryname = progname;
  447.     entries = p;
  448.  
  449.     procclass = class;
  450.     fprintf(diagfile, "   %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") );
  451.     if(progname) {
  452.         fprintf(diagfile, " %s", progname->fextname);
  453.         procname = progname->cextname;
  454.         }
  455.     fprintf(diagfile, ":\n");
  456.     fflush(diagfile);
  457. }
  458.  
  459. /* subroutine or function statement */
  460.  
  461.  Extsym *
  462. #ifdef KR_headers
  463. newentry(v, substmsg)
  464.     register Namep v;
  465.     int substmsg;
  466. #else
  467. newentry(register Namep v, int substmsg)
  468. #endif
  469. {
  470.     register Extsym *p;
  471.     char buf[128], badname[64];
  472.     static int nbad = 0;
  473.     static char already[] = "external name already used";
  474.  
  475.     p = mkext(v->fvarname, addunder(v->cvarname));
  476.  
  477.     if(p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
  478.     {
  479.         sprintf(badname, "%s_bad%d", v->fvarname, ++nbad);
  480.         if (substmsg) {
  481.             sprintf(buf,"%s\n\tsubstituting \"%s\"",
  482.                 already, badname);
  483.             dclerr(buf, v);
  484.             }
  485.         else
  486.             dclerr(already, v);
  487.         p = mkext(v->fvarname, badname);
  488.     }
  489.     v->vstg = STGAUTO;
  490.     v->vprocclass = PTHISPROC;
  491.     v->vclass = CLPROC;
  492.     if (p->extstg == STGEXT)
  493.         prev_proc = 1;
  494.     else
  495.         p->extstg = STGEXT;
  496.     p->extinit = YES;
  497.     v->vardesc.varno = p - extsymtab;
  498.     return(p);
  499. }
  500.  
  501.  void
  502. #ifdef KR_headers
  503. entrypt(class, type, length, entry, args)
  504.     int class;
  505.     int type;
  506.     ftnint length;
  507.     Extsym *entry;
  508.     chainp args;
  509. #else
  510. entrypt(int class, int type, ftnint length, Extsym *entry, chainp args)
  511. #endif
  512. {
  513.     register Namep q;
  514.     register struct Entrypoint *p;
  515.  
  516.     if(class != CLENTRY)
  517.         puthead( procname = entry->cextname, class);
  518.     else
  519.         fprintf(diagfile, "       entry ");
  520.     fprintf(diagfile, "   %s:\n", entry->fextname);
  521.     fflush(diagfile);
  522.     q = mkname(entry->fextname);
  523.     if (type == TYSUBR)
  524.         q->vstg = STGEXT;
  525.  
  526.     type = lengtype(type, length);
  527.     if(class == CLPROC)
  528.     {
  529.         procclass = CLPROC;
  530.         proctype = type;
  531.         procleng = type == TYCHAR ? length : 0;
  532.     }
  533.  
  534.     p = ALLOC(Entrypoint);
  535.  
  536.     p->entnextp = entries;
  537.     entries = p;
  538.  
  539.     p->entryname = entry;
  540.     p->arglist = revchain(args);
  541.     p->enamep = q;
  542.  
  543.     if(class == CLENTRY)
  544.     {
  545.         class = CLPROC;
  546.         if(proctype == TYSUBR)
  547.             type = TYSUBR;
  548.     }
  549.  
  550.     q->vclass = class;
  551.     q->vprocclass = 0;
  552.     settype(q, type, length);
  553.     q->vprocclass = PTHISPROC;
  554.     /* hold all initial entry points till end of declarations */
  555.     if(parstate >= INDATA)
  556.         doentry(p);
  557. }
  558.  
  559. /* generate epilogs */
  560.  
  561. /* epicode -- write out the proper function return mechanism at the end of
  562.    the procedure declaration.  Handles multiple return value types, as
  563.    well as cooercion into the proper value */
  564.  
  565.  LOCAL void
  566. epicode(Void)
  567. {
  568.     extern int lastwasbranch;
  569.  
  570.     if(procclass==CLPROC)
  571.     {
  572.         if(proctype==TYSUBR)
  573.         {
  574.  
  575. /* Return a zero only when the alternate return mechanism has been
  576.    specified in the function header */
  577.  
  578.             if ((substars || Ansi) && lastwasbranch != YES)
  579.                 p1_subr_ret (ICON(0));
  580.         }
  581.         else if (!multitype && lastwasbranch != YES)
  582.             retval(proctype);
  583.     }
  584.     else if (procclass == CLMAIN && Ansi && lastwasbranch != YES)
  585.         p1_subr_ret (ICON(0));
  586.     lastwasbranch = NO;
  587. }
  588.  
  589.  
  590. /* generate code to return value of type  t */
  591.  
  592.  LOCAL void
  593. #ifdef KR_headers
  594. retval(t)
  595.     register int t;
  596. #else
  597. retval(register int t)
  598. #endif
  599. {
  600.     register Addrp p;
  601.  
  602.     switch(t)
  603.     {
  604.     case TYCHAR:
  605.     case TYCOMPLEX:
  606.     case TYDCOMPLEX:
  607.         break;
  608.  
  609.     case TYLOGICAL:
  610.         t = tylogical;
  611.     case TYINT1:
  612.     case TYADDR:
  613.     case TYSHORT:
  614.     case TYLONG:
  615. #ifdef TYQUAD
  616.     case TYQUAD:
  617. #endif
  618.     case TYREAL:
  619.     case TYDREAL:
  620.     case TYLOGICAL1:
  621.     case TYLOGICAL2:
  622.         p = (Addrp) cpexpr((expptr)retslot);
  623.         p->vtype = t;
  624.         p1_subr_ret (mkconv (t, fixtype((expptr)p)));
  625.         break;
  626.  
  627.     default:
  628.         badtype("retval", t);
  629.     }
  630. }
  631.  
  632.  
  633. /* Do parameter adjustments */
  634.  
  635.  void
  636. #ifdef KR_headers
  637. procode(outfile)
  638.     FILE *outfile;
  639. #else
  640. procode(FILE *outfile)
  641. #endif
  642. {
  643.     prolog(outfile, allargs);
  644.  
  645.     if (nentry > 1)
  646.         entry_goto(outfile);
  647.     }
  648.  
  649.  static void
  650. #ifdef KR_headers
  651. bad_dimtype(q) Namep q;
  652. #else
  653. bad_dimtype(Namep q)
  654. #endif
  655. {
  656.     errstr("bad dimension type for %.70s", q->fvarname);
  657.     }
  658.  
  659. /* Finish bound computations now that all variables are declared.
  660.  * This used to be in setbound(), but under -u the following incurred
  661.  * an erroneous error message:
  662.  *    subroutine foo(x,n)
  663.  *    real x(n)
  664.  *    integer n
  665.  */
  666.  
  667.  static void
  668. #ifdef KR_headers
  669. dim_finish(v)
  670.     Namep v;
  671. #else
  672. dim_finish(Namep v)
  673. #endif
  674. {
  675.     register struct Dimblock *p;
  676.     register expptr q;
  677.     register int i, nd;
  678.  
  679.     p = v->vdim;
  680.     v->vdimfinish = 0;
  681.     nd = p->ndim;
  682.     doin_setbound = 1;
  683.     for(i = 0; i < nd; i++)
  684.         if (q = p->dims[i].dimexpr) {
  685.             q = p->dims[i].dimexpr = make_int_expr(putx(fixtype(q)));
  686.             if (!ONEOF(q->headblock.vtype, MSKINT|MSKREAL))
  687.                 bad_dimtype(v);
  688.             }
  689.     if (q = p->basexpr)
  690.         p->basexpr = make_int_expr(putx(fixtype(q)));
  691.     doin_setbound = 0;
  692.     }
  693.  
  694.  static void
  695. #ifdef KR_headers
  696. duparg(q)
  697.     Namep q;
  698. #else
  699. duparg(Namep q)
  700. #endif
  701. { errstr("duplicate argument %.80s", q->fvarname); }
  702.  
  703. /*
  704.    manipulate argument lists (allocate argument slot positions)
  705.  * keep track of return types and labels
  706.  */
  707.  
  708.  LOCAL void
  709. #ifdef KR_headers
  710. doentry(ep)
  711.     struct Entrypoint *ep;
  712. #else
  713. doentry(struct Entrypoint *ep)
  714. #endif
  715. {
  716.     register int type;
  717.     register Namep np;
  718.     chainp p, p1;
  719.     register Namep q;
  720.     Addrp rs;
  721.     int it, k;
  722.     extern char dflttype[26];
  723.     Extsym *entryname = ep->entryname;
  724.  
  725.     if (++nentry > 1)
  726.         p1_label((long)(extsymtab - entryname - 1));
  727.  
  728. /* The main program isn't allowed to have parameters, so any given
  729.    parameters are ignored */
  730.  
  731.     if(procclass == CLMAIN || procclass == CLBLOCK)
  732.         return;
  733.  
  734. /* So now we're working with something other than CLMAIN or CLBLOCK.
  735.    Determine the type of its return value. */
  736.  
  737.     impldcl( np = mkname(entryname->fextname) );
  738.     type = np->vtype;
  739.     proc_argchanges = prev_proc && type != entryname->extype;
  740.     entryname->extseen = 1;
  741.     if(proctype == TYUNKNOWN)
  742.         if( (proctype = type) == TYCHAR)
  743.             procleng = np->vleng ? np->vleng->constblock.Const.ci
  744.                          : (ftnint) (-1);
  745.  
  746.     if(proctype == TYCHAR)
  747.     {
  748.         if(type != TYCHAR)
  749.             err("noncharacter entry of character function");
  750.  
  751. /* Functions returning type   char   can only have multiple entries if all
  752.    entries return the same length */
  753.  
  754.         else if( (np->vleng ? np->vleng->constblock.Const.ci :
  755.             (ftnint) (-1)) != procleng)
  756.             err("mismatched character entry lengths");
  757.     }
  758.     else if(type == TYCHAR)
  759.         err("character entry of noncharacter function");
  760.     else if(type != proctype)
  761.         multitype = YES;
  762.     if(rtvlabel[type] == 0)
  763.         rtvlabel[type] = newlabel();
  764.     ep->typelabel = rtvlabel[type];
  765.  
  766.     if(type == TYCHAR)
  767.     {
  768.         if(chslot < 0)
  769.         {
  770.             chslot = nextarg(TYADDR);
  771.             chlgslot = nextarg(TYLENG);
  772.         }
  773.         np->vstg = STGARG;
  774.  
  775. /* Put a new argument in the function, one which will hold the result of
  776.    a character function.  This will have to be named sometime, probably in
  777.    mkarg(). */
  778.  
  779.         if(procleng < 0) {
  780.             np->vleng = (expptr) mkarg(TYLENG, chlgslot);
  781.             np->vleng->addrblock.uname_tag = UNAM_IDENT;
  782.             strcpy (np -> vleng -> addrblock.user.ident,
  783.                 new_func_length());
  784.             }
  785.         if (!xretslot[TYCHAR]) {
  786.             xretslot[TYCHAR] = rs =
  787.                 autovar(0, type, ISCONST(np->vleng)
  788.                     ? np->vleng : ICON(0), "");
  789.             strcpy(rs->user.ident, "ret_val");
  790.             }
  791.     }
  792.  
  793. /* Handle a   complex   return type -- declare a new parameter (pointer to
  794.    a complex value) */
  795.  
  796.     else if( ISCOMPLEX(type) ) {
  797.         if (!xretslot[type])
  798.             xretslot[type] =
  799.                 autovar(0, type, EXNULL, " ret_val");
  800.                 /* the blank is for use in out_addr */
  801.         np->vstg = STGARG;
  802.         if(cxslot < 0)
  803.             cxslot = nextarg(TYADDR);
  804.         }
  805.     else if (type != TYSUBR) {
  806.         if (type == TYUNKNOWN) {
  807.             dclerr("untyped function", np);
  808.             proctype = type = np->vtype =
  809.                 dflttype[letter(np->fvarname[0])];
  810.             }
  811.         if (!xretslot[type])
  812.             xretslot[type] = retslot =
  813.                 autovar(1, type, EXNULL, " ret_val");
  814.                 /* the blank is for use in out_addr */
  815.         np->vstg = STGAUTO;
  816.         }
  817.  
  818.     for(p = ep->arglist ; p ; p = p->nextp)
  819.         if(! (( q = (Namep) (p->datap) )->vknownarg) ) {
  820.             q->vknownarg = 1;
  821.             q->vardesc.varno = nextarg(TYADDR);
  822.             allargs = mkchain((char *)q, allargs);
  823.             q->argno = nallargs++;
  824.             }
  825.         else if (nentry == 1)
  826.             duparg(q);
  827.         else for(p1 = ep->arglist ; p1 != p; p1 = p1->nextp)
  828.             if ((Namep)p1->datap == q)
  829.                 duparg(q);
  830.  
  831.     k = 0;
  832.     for(p = ep->arglist ; p ; p = p->nextp) {
  833.         if(! (( q = (Namep) (p->datap) )->vdcldone) )
  834.             {
  835.             impldcl(q);
  836.             q->vdcldone = YES;
  837.             if(q->vtype == TYCHAR)
  838.                 {
  839.  
  840. /* If we don't know the length of a char*(*) (i.e. a string), we must add
  841.    in this additional length argument. */
  842.  
  843.                 ++nallchargs;
  844.                 if (q->vclass == CLPROC)
  845.                     nallchargs--;
  846.                 else if (q->vleng == NULL) {
  847.                     /* character*(*) */
  848.                     q->vleng = (expptr)
  849.                         mkarg(TYLENG, nextarg(TYLENG) );
  850.                     unamstring((Addrp)q->vleng,
  851.                         new_arg_length(q));
  852.                     }
  853.                 }
  854.             }
  855.         if (q->vdimfinish)
  856.             dim_finish(q);
  857.         if (q->vtype == TYCHAR && q->vclass != CLPROC)
  858.             k++;
  859.         }
  860.  
  861.     if (entryname->extype != type)
  862.         changedtype(np);
  863.  
  864.     /* save information for checking consistency of arg lists */
  865.  
  866.     it = infertypes;
  867.     if (entryname->exproto)
  868.         infertypes = 1;
  869.     save_argtypes(ep->arglist, &entryname->arginfo, &np->arginfo,
  870.             0, np->fvarname, STGEXT, k, np->vtype, 2);
  871.     infertypes = it;
  872. }
  873.  
  874.  
  875.  
  876.  LOCAL int
  877. #ifdef KR_headers
  878. nextarg(type)
  879.     int type;
  880. #else
  881. nextarg(int type)
  882. #endif
  883. {
  884.     type = type;    /* shut up warning */
  885.     return(lastargslot++);
  886.     }
  887.  
  888.  LOCAL void
  889. #ifdef KR_headers
  890. dim_check(q)
  891.     Namep q;
  892. #else
  893. dim_check(Namep q)
  894. #endif
  895. {
  896.     register struct Dimblock *vdim = q->vdim;
  897.     register expptr nelt;
  898.  
  899.     if(!(nelt = vdim->nelt) || !ISCONST(nelt))
  900.         dclerr("adjustable dimension on non-argument", q);
  901.     else if (!ONEOF(nelt->headblock.vtype, MSKINT|MSKREAL))
  902.         bad_dimtype(q);
  903.     else if (ISINT(nelt->headblock.vtype)
  904.             && nelt->constblock.Const.ci <= 0
  905.          || nelt->constblock.Const.cd[0] <= 0)
  906.         dclerr("nonpositive dimension", q);
  907.     }
  908.  
  909.  LOCAL void
  910. dobss(Void)
  911. {
  912.     register struct Hashentry *p;
  913.     register Namep q;
  914.     int qstg, qclass, qtype;
  915.     Extsym *e;
  916.  
  917.     for(p = hashtab ; p<lasthash ; ++p)
  918.         if(q = p->varp)
  919.         {
  920.             qstg = q->vstg;
  921.             qtype = q->vtype;
  922.             qclass = q->vclass;
  923.  
  924.             if( (qclass==CLUNKNOWN && qstg!=STGARG) ||
  925.                 (qclass==CLVAR && qstg==STGUNKNOWN) ) {
  926.                 if (!(q->vis_assigned | q->vimpldovar))
  927.                     warn1("local variable %s never used",
  928.                         q->fvarname);
  929.                 }
  930.             else if(qclass==CLVAR && qstg==STGBSS)
  931.             { ; }
  932.  
  933. /* Give external procedures the proper storage class */
  934.  
  935.             else if(qclass==CLPROC && q->vprocclass==PEXTERNAL
  936.                     && qstg!=STGARG) {
  937.                 e = mkext(q->fvarname,addunder(q->cvarname));
  938.                 e->extstg = STGEXT;
  939.                 q->vardesc.varno = e - extsymtab;
  940.                 if (e->extype != qtype)
  941.                     changedtype(q);
  942.                 }
  943.             if(qclass==CLVAR) {
  944.                 if (qstg != STGARG && q->vdim)
  945.                 dim_check(q);
  946.             } /* if qclass == CLVAR */
  947.         }
  948.  
  949. }
  950.  
  951.  
  952.  void
  953. donmlist(Void)
  954. {
  955.     register struct Hashentry *p;
  956.     register Namep q;
  957.  
  958.     for(p=hashtab; p<lasthash; ++p)
  959.         if( (q = p->varp) && q->vclass==CLNAMELIST)
  960.             namelist(q);
  961. }
  962.  
  963.  
  964. /* iarrlen -- Returns the size of the array in bytes, or -1 */
  965.  
  966.  ftnint
  967. #ifdef KR_headers
  968. iarrlen(q)
  969.     register Namep q;
  970. #else
  971. iarrlen(register Namep q)
  972. #endif
  973. {
  974.     ftnint leng;
  975.  
  976.     leng = typesize[q->vtype];
  977.     if(leng <= 0)
  978.         return(-1);
  979.     if(q->vdim)
  980.         if( ISICON(q->vdim->nelt) )
  981.             leng *= q->vdim->nelt->constblock.Const.ci;
  982.         else    return(-1);
  983.     if(q->vleng)
  984.         if( ISICON(q->vleng) )
  985.             leng *= q->vleng->constblock.Const.ci;
  986.         else return(-1);
  987.     return(leng);
  988. }
  989.  
  990.  void
  991. #ifdef KR_headers
  992. namelist(np)
  993.     Namep np;
  994. #else
  995. namelist(Namep np)
  996. #endif
  997. {
  998.     register chainp q;
  999.     register Namep v;
  1000.     int y;
  1001.  
  1002.     if (!np->visused)
  1003.         return;
  1004.     y = 0;
  1005.  
  1006.     for(q = np->varxptr.namelist ; q ; q = q->nextp)
  1007.     {
  1008.         vardcl( v = (Namep) (q->datap) );
  1009.         if( !ONEOF(v->vstg, MSKSTATIC) )
  1010.             dclerr("may not appear in namelist", v);
  1011.         else {
  1012.             v->vnamelist = 1;
  1013.             v->visused = 1;
  1014.             v->vsave = 1;
  1015.             y = 1;
  1016.             }
  1017.     np->visused = y;
  1018.     }
  1019. }
  1020.  
  1021. /* docommon -- called at the end of procedure declarations, before
  1022.    equivalences and the procedure body */
  1023.  
  1024.  LOCAL void
  1025. docommon(Void)
  1026. {
  1027.     register Extsym *extptr;
  1028.     register chainp q, q1;
  1029.     struct Dimblock *t;
  1030.     expptr neltp;
  1031.     register Namep comvar;
  1032.     ftnint size;
  1033.     int i, k, pref, type;
  1034.     extern int type_pref[];
  1035.  
  1036.     for(extptr = extsymtab ; extptr<nextext ; ++extptr)
  1037.     if (extptr->extstg == STGCOMMON && (q = extptr->extp)) {
  1038.  
  1039. /* If a common declaration also had a list of variables ... */
  1040.  
  1041.         q = extptr->extp = revchain(q);
  1042.         pref = 1;
  1043.         for(k = TYCHAR; q ; q = q->nextp)
  1044.         {
  1045.         comvar = (Namep) (q->datap);
  1046.  
  1047.         if(comvar->vdcldone == NO)
  1048.             vardcl(comvar);
  1049.         type = comvar->vtype;
  1050.         if (pref < type_pref[type])
  1051.             pref = type_pref[k = type];
  1052.         if(extptr->extleng % typealign[type] != 0) {
  1053.             dclerr("common alignment", comvar);
  1054.             --nerr; /* don't give bad return code for this */
  1055. #if 0
  1056.             extptr->extleng = roundup(extptr->extleng, typealign[type]);
  1057. #endif
  1058.         } /* if extptr -> extleng % */
  1059.  
  1060. /* Set the offset into the common block */
  1061.  
  1062.         comvar->voffset = extptr->extleng;
  1063.         comvar->vardesc.varno = extptr - extsymtab;
  1064.         if(type == TYCHAR)
  1065.             size = comvar->vleng->constblock.Const.ci;
  1066.         else
  1067.             size = typesize[type];
  1068.         if(t = comvar->vdim)
  1069.             if( (neltp = t->nelt) && ISCONST(neltp) )
  1070.             size *= neltp->constblock.Const.ci;
  1071.             else
  1072.             dclerr("adjustable array in common", comvar);
  1073.  
  1074. /* Adjust the length of the common block so far */
  1075.  
  1076.         extptr->extleng += size;
  1077.         } /* for */
  1078.  
  1079.         extptr->extype = k;
  1080.  
  1081. /* Determine curno and, if new, save this identifier chain */
  1082.  
  1083.         q1 = extptr->extp;
  1084.         for (q = extptr->allextp, i = 0; q; i++, q = q->nextp)
  1085.         if (struct_eq((chainp)q->datap, q1))
  1086.             break;
  1087.         if (q)
  1088.         extptr->curno = extptr->maxno - i;
  1089.         else {
  1090.         extptr->curno = ++extptr->maxno;
  1091.         extptr->allextp = mkchain((char *)extptr->extp,
  1092.                         extptr->allextp);
  1093.         }
  1094.     } /* if extptr -> extstg == STGCOMMON */
  1095.  
  1096. /* Now the hash table entries have STGCOMMON, vdcldone, voffset, and
  1097.    varno.  And the common block itself has its full size in extleng. */
  1098.  
  1099. } /* docommon */
  1100.  
  1101.  
  1102. /* copy_data -- copy the Namep entries so they are available even after
  1103.    the hash table is empty */
  1104.  
  1105.  void
  1106. #ifdef KR_headers
  1107. copy_data(list)
  1108.     chainp list;
  1109. #else
  1110. copy_data(chainp list)
  1111. #endif
  1112. {
  1113.     for (; list; list = list -> nextp) {
  1114.     Namep namep = ALLOC (Nameblock);
  1115.     int size, nd, i;
  1116.     struct Dimblock *dp;
  1117.  
  1118.     cpn(sizeof(struct Nameblock), list->datap, (char *)namep);
  1119.     namep->fvarname = strcpy(gmem(strlen(namep->fvarname)+1,0),
  1120.         namep->fvarname);
  1121.     namep->cvarname = strcmp(namep->fvarname, namep->cvarname)
  1122.         ? strcpy(gmem(strlen(namep->cvarname)+1,0), namep->cvarname)
  1123.         : namep->fvarname;
  1124.     if (namep -> vleng)
  1125.         namep -> vleng = (expptr) cpexpr (namep -> vleng);
  1126.     if (namep -> vdim) {
  1127.         nd = namep -> vdim -> ndim;
  1128.         size = sizeof(int) + (3 + 2 * nd) * sizeof (expptr);
  1129.         dp = (struct Dimblock *) ckalloc (size);
  1130.         cpn(size, (char *)namep->vdim, (char *)dp);
  1131.         namep -> vdim = dp;
  1132.         dp->nelt = (expptr)cpexpr(dp->nelt);
  1133.         for (i = 0; i < nd; i++) {
  1134.         dp -> dims[i].dimsize = (expptr) cpexpr (dp -> dims[i].dimsize);
  1135.         } /* for */
  1136.     } /* if */
  1137.     list -> datap = (char *) namep;
  1138.     } /* for */
  1139. } /* copy_data */
  1140.  
  1141.  
  1142.  
  1143.  LOCAL void
  1144. docomleng(Void)
  1145. {
  1146.     register Extsym *p;
  1147.  
  1148.     for(p = extsymtab ; p < nextext ; ++p)
  1149.         if(p->extstg == STGCOMMON)
  1150.         {
  1151.             if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng
  1152.                 && strcmp(Blank, p->cextname) )
  1153.                 warn1("incompatible lengths for common block %.60s",
  1154.                     p->fextname);
  1155.             if(p->maxleng < p->extleng)
  1156.                 p->maxleng = p->extleng;
  1157.             p->extleng = 0;
  1158.         }
  1159. }
  1160.  
  1161.  
  1162. /* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */
  1163.  
  1164.  void
  1165. #ifdef KR_headers
  1166. frtemp(p)
  1167.     Addrp p;
  1168. #else
  1169. frtemp(Addrp p)
  1170. #endif
  1171. {
  1172.     /* put block on chain of temps to be reclaimed */
  1173.     holdtemps = mkchain((char *)p, holdtemps);
  1174. }
  1175.  
  1176.  void
  1177. freetemps(Void)
  1178. {
  1179.     register chainp p, p1;
  1180.     register Addrp q;
  1181.     register int t;
  1182.  
  1183.     p1 = holdtemps;
  1184.     while(p = p1) {
  1185.         q = (Addrp)p->datap;
  1186.         t = q->vtype;
  1187.         if (t == TYCHAR && q->varleng != 0) {
  1188.             /* restore clobbered character string lengths */
  1189.             frexpr(q->vleng);
  1190.             q->vleng = ICON(q->varleng);
  1191.             }
  1192.         p1 = p->nextp;
  1193.         p->nextp = templist[t];
  1194.         templist[t] = p;
  1195.         }
  1196.     holdtemps = 0;
  1197.     }
  1198.  
  1199. /* allocate an automatic variable slot for each of   nelt   variables */
  1200.  
  1201.  Addrp
  1202. #ifdef KR_headers
  1203. autovar(nelt0, t, lengp, name)
  1204.     register int nelt0;
  1205.     register int t;
  1206.     expptr lengp;
  1207.     char *name;
  1208. #else
  1209. autovar(register int nelt0, register int t, expptr lengp, char *name)
  1210. #endif
  1211. {
  1212.     ftnint leng;
  1213.     register Addrp q;
  1214.     register int nelt = nelt0 > 0 ? nelt0 : 1;
  1215.     extern char *av_pfix[];
  1216.  
  1217.     if(t == TYCHAR)
  1218.         if( ISICON(lengp) )
  1219.             leng = lengp->constblock.Const.ci;
  1220.         else    {
  1221.             Fatal("automatic variable of nonconstant length");
  1222.         }
  1223.     else
  1224.         leng = typesize[t];
  1225.  
  1226.     q = ALLOC(Addrblock);
  1227.     q->tag = TADDR;
  1228.     q->vtype = t;
  1229.     if(t == TYCHAR)
  1230.     {
  1231.         q->vleng = ICON(leng);
  1232.         q->varleng = leng;
  1233.     }
  1234.     q->vstg = STGAUTO;
  1235.     q->ntempelt = nelt;
  1236.     q->isarray = (nelt > 1);
  1237.     q->memoffset = ICON(0);
  1238.  
  1239.     /* kludge for nls so we can have ret_val rather than ret_val_4 */
  1240.     if (*name == ' ')
  1241.         unamstring(q, name);
  1242.     else {
  1243.         q->uname_tag = UNAM_IDENT;
  1244.         temp_name(av_pfix[t], ++autonum[t], q->user.ident);
  1245.         }
  1246.     if (nelt0 > 0)
  1247.         declare_new_addr (q);
  1248.     return(q);
  1249. }
  1250.  
  1251.  
  1252. /* Returns a temporary of the appropriate type.  Will reuse existing
  1253.    temporaries when possible */
  1254.  
  1255.  Addrp
  1256. #ifdef KR_headers
  1257. mktmpn(nelt, type, lengp)
  1258.     int nelt;
  1259.     register int type;
  1260.     expptr lengp;
  1261. #else
  1262. mktmpn(int nelt, register int type, expptr lengp)
  1263. #endif
  1264. {
  1265.     ftnint leng;
  1266.     chainp p, oldp;
  1267.     register Addrp q;
  1268.     extern int krparens;
  1269.  
  1270.     if(type==TYUNKNOWN || type==TYERROR)
  1271.         badtype("mktmpn", type);
  1272.  
  1273.     if(type==TYCHAR)
  1274.         if(lengp && ISICON(lengp) )
  1275.             leng = lengp->constblock.Const.ci;
  1276.         else    {
  1277.             err("adjustable length");
  1278.             return( (Addrp) errnode() );
  1279.         }
  1280.     else if (type > TYCHAR || type < TYADDR) {
  1281.         erri("mktmpn: unexpected type %d", type);
  1282.         exit(1);
  1283.         }
  1284. /*
  1285.  * if a temporary of appropriate shape is on the templist,
  1286.  * remove it from the list and return it
  1287.  */
  1288.     if (krparens == 2 && ONEOF(type,M(TYREAL)|M(TYCOMPLEX)))
  1289.         type++;
  1290.     for(oldp=CHNULL, p=templist[type];  p  ;  oldp=p, p=p->nextp)
  1291.     {
  1292.         q = (Addrp) (p->datap);
  1293.         if(q->ntempelt==nelt &&
  1294.             (type!=TYCHAR || q->vleng->constblock.Const.ci==leng) )
  1295.         {
  1296.             if(oldp)
  1297.                 oldp->nextp = p->nextp;
  1298.             else
  1299.                 templist[type] = p->nextp;
  1300.             free( (charptr) p);
  1301.             return(q);
  1302.         }
  1303.     }
  1304.     q = autovar(nelt, type, lengp, "");
  1305.     return(q);
  1306. }
  1307.  
  1308.  
  1309.  
  1310.  
  1311. /* mktmp -- create new local variable; call it something like   name
  1312.    lengp   is taken directly, not copied */
  1313.  
  1314.  Addrp
  1315. #ifdef KR_headers
  1316. mktmp(type, lengp)
  1317.     int type;
  1318.     expptr lengp;
  1319. #else
  1320. mktmp(int type, expptr lengp)
  1321. #endif
  1322. {
  1323.     Addrp rv;
  1324.     /* arrange for temporaries to be recycled */
  1325.     /* at the end of this statement... */
  1326.     rv = mktmpn(1,type,lengp);
  1327.     frtemp((Addrp)cpexpr((expptr)rv));
  1328.     return rv;
  1329. }
  1330.  
  1331. /* mktmp0 omits frtemp() */
  1332.  Addrp
  1333. #ifdef KR_headers
  1334. mktmp0(type, lengp)
  1335.     int type;
  1336.     expptr lengp;
  1337. #else
  1338. mktmp0(int type, expptr lengp)
  1339. #endif
  1340. {
  1341.     Addrp rv;
  1342.     /* arrange for temporaries to be recycled */
  1343.     /* when this Addrp is freed */
  1344.     rv = mktmpn(1,type,lengp);
  1345.     rv->istemp = YES;
  1346.     return rv;
  1347. }
  1348.  
  1349. /* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */
  1350.  
  1351. /* comblock -- Declare a new common block.  Input parameters name the block;
  1352.    s   will be NULL if the block is unnamed */
  1353.  
  1354.  Extsym *
  1355. #ifdef KR_headers
  1356. comblock(s)
  1357.     register char *s;
  1358. #else
  1359. comblock(register char *s)
  1360. #endif
  1361. {
  1362.     Extsym *p;
  1363.     register char *t;
  1364.     register int c, i;
  1365.     char cbuf[256], *s0;
  1366.  
  1367. /* Give the unnamed common block a unique name */
  1368.  
  1369.     if(*s == 0)
  1370.         p = mkext1(s0 = Blank, Blank);
  1371.     else {
  1372.         s0 = s;
  1373.         t = cbuf;
  1374.         for(i = 0; c = *t = *s++; t++)
  1375.             if (c == '_')
  1376.                 i = 1;
  1377.         if (i)
  1378.             *t++ = '_';
  1379.         t[0] = '_';
  1380.         t[1] = 0;
  1381.         p = mkext1(s0,cbuf);
  1382.         }
  1383.     if(p->extstg == STGUNKNOWN)
  1384.         p->extstg = STGCOMMON;
  1385.     else if(p->extstg != STGCOMMON)
  1386.     {
  1387.         errstr("%.52s cannot be a common block: it is a subprogram.",
  1388.             s0);
  1389.         return(0);
  1390.     }
  1391.  
  1392.     return( p );
  1393. }
  1394.  
  1395.  
  1396. /* incomm -- add a new variable to a common declaration */
  1397.  
  1398.  void
  1399. #ifdef KR_headers
  1400. incomm(c, v)
  1401.     Extsym *c;
  1402.     Namep v;
  1403. #else
  1404. incomm(Extsym *c, Namep v)
  1405. #endif
  1406. {
  1407.     if (!c)
  1408.         return;
  1409.     if(v->vstg != STGUNKNOWN && !v->vimplstg)
  1410.         dclerr(v->vstg == STGARG
  1411.             ? "dummy arguments cannot be in common"
  1412.             : "incompatible common declaration", v);
  1413.     else
  1414.     {
  1415.         v->vstg = STGCOMMON;
  1416.         c->extp = mkchain((char *)v, c->extp);
  1417.     }
  1418. }
  1419.  
  1420.  
  1421.  
  1422.  
  1423. /* settype -- set the type or storage class of a Namep object.  If
  1424.    v -> vstg == STGUNKNOWN && type < 0,   attempt to reset vstg to be
  1425.    -type.  This function will not change any earlier definitions in   v,
  1426.    in will only attempt to fill out more information give the other params */
  1427.  
  1428.  void
  1429. #ifdef KR_headers
  1430. settype(v, type, length)
  1431.     register Namep v;
  1432.     register int type;
  1433.     register ftnint length;
  1434. #else
  1435. settype(register Namep v, register int type, register ftnint length)
  1436. #endif
  1437. {
  1438.     int type1;
  1439.  
  1440.     if(type == TYUNKNOWN)
  1441.         return;
  1442.  
  1443.     if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
  1444.     {
  1445.         v->vtype = TYSUBR;
  1446.         frexpr(v->vleng);
  1447.         v->vleng = 0;
  1448.         v->vimpltype = 0;
  1449.     }
  1450.     else if(type < 0)    /* storage class set */
  1451.     {
  1452.         if(v->vstg == STGUNKNOWN)
  1453.             v->vstg = - type;
  1454.         else if(v->vstg != -type)
  1455.             dclerr("incompatible storage declarations", v);
  1456.     }
  1457.     else if(v->vtype == TYUNKNOWN || v->vimpltype && v->vtype != type)
  1458.     {
  1459.         if( (v->vtype = lengtype(type, length))==TYCHAR )
  1460.             if (length>=0)
  1461.                 v->vleng = ICON(length);
  1462.             else if (parstate >= INDATA)
  1463.                 v->vleng = ICON(1);    /* avoid a memory fault */
  1464.         v->vimpltype = 0;
  1465.  
  1466.         if (v->vclass == CLPROC) {
  1467.             if (v->vstg == STGEXT
  1468.              && (type1 = extsymtab[v->vardesc.varno].extype)
  1469.              &&  type1 != v->vtype)
  1470.                 changedtype(v);
  1471.             else if (v->vprocclass == PTHISPROC
  1472.                     && (parstate >= INDATA
  1473.                         || procclass == CLMAIN)
  1474.                     && !xretslot[type]) {
  1475.                 xretslot[type] = autovar(ONEOF(type,
  1476.                     MSKCOMPLEX|MSKCHAR) ? 0 : 1, type,
  1477.                     v->vleng, " ret_val");
  1478.                 if (procclass == CLMAIN)
  1479.                     errstr(
  1480.                 "illegal use of %.60s (main program name)",
  1481.                     v->fvarname);
  1482.                 /* not completely right, but enough to */
  1483.                 /* avoid memory faults; we won't */
  1484.                 /* emit any C as we have illegal Fortran */
  1485.                 }
  1486.             }
  1487.     }
  1488.     else if(v->vtype!=type) {
  1489.  incompat:
  1490.         dclerr("incompatible type declarations", v);
  1491.         }
  1492.     else if (type==TYCHAR)
  1493.         if (v->vleng && v->vleng->constblock.Const.ci != length)
  1494.             goto incompat;
  1495.         else if (parstate >= INDATA)
  1496.             v->vleng = ICON(1);    /* avoid a memory fault */
  1497. }
  1498.  
  1499.  
  1500.  
  1501.  
  1502.  
  1503. /* lengtype -- returns the proper compiler type, given input of Fortran
  1504.    type and length specifier */
  1505.  
  1506.  int
  1507. #ifdef KR_headers
  1508. lengtype(type, len)
  1509.     register int type;
  1510.     ftnint len;
  1511. #else
  1512. lengtype(register int type, ftnint len)
  1513. #endif
  1514. {
  1515.     register int length = (int)len;
  1516.     switch(type)
  1517.     {
  1518.     case TYREAL:
  1519.         if(length == typesize[TYDREAL])
  1520.             return(TYDREAL);
  1521.         if(length == typesize[TYREAL])
  1522.             goto ret;
  1523.         break;
  1524.  
  1525.     case TYCOMPLEX:
  1526.         if(length == typesize[TYDCOMPLEX])
  1527.             return(TYDCOMPLEX);
  1528.         if(length == typesize[TYCOMPLEX])
  1529.             goto ret;
  1530.         break;
  1531.  
  1532.     case TYINT1:
  1533.     case TYSHORT:
  1534.     case TYDREAL:
  1535.     case TYDCOMPLEX:
  1536.     case TYCHAR:
  1537.     case TYLOGICAL1:
  1538.     case TYLOGICAL2:
  1539.     case TYUNKNOWN:
  1540.     case TYSUBR:
  1541.     case TYERROR:
  1542. #ifdef TYQUAD
  1543.     case TYQUAD:
  1544. #endif
  1545.         goto ret;
  1546.  
  1547.     case TYLOGICAL:
  1548.         switch(length) {
  1549.             case 0: return tylog;
  1550.             case 1:    return TYLOGICAL1;
  1551.             case 2: return TYLOGICAL2;
  1552.             case 4: goto ret;
  1553.             }
  1554. #if 0 /*!!??!!*/
  1555.         if(length == typesize[TYLOGICAL])
  1556.             goto ret;
  1557. #endif
  1558.         break;
  1559.  
  1560.     case TYLONG:
  1561.         if(length == 0)
  1562.             return(tyint);
  1563.         if (length == 1)
  1564.             return TYINT1;
  1565.         if(length == typesize[TYSHORT])
  1566.             return(TYSHORT);
  1567. #ifdef TYQUAD
  1568.         if(length == typesize[TYQUAD] && use_tyquad)
  1569.             return(TYQUAD);
  1570. #endif
  1571.         if(length == typesize[TYLONG])
  1572.             goto ret;
  1573.         break;
  1574.     default:
  1575.         badtype("lengtype", type);
  1576.     }
  1577.  
  1578.     if(len != 0)
  1579.         err("incompatible type-length combination");
  1580.  
  1581. ret:
  1582.     return(type);
  1583. }
  1584.  
  1585.  
  1586.  
  1587.  
  1588.  
  1589. /* setintr -- Set Intrinsic function */
  1590.  
  1591.  void
  1592. #ifdef KR_headers
  1593. setintr(v)
  1594.     register Namep v;
  1595. #else
  1596. setintr(register Namep v)
  1597. #endif
  1598. {
  1599.     int k;
  1600.  
  1601.     if(k = intrfunct(v->fvarname)) {
  1602.         if ((*(struct Intrpacked *)&k).f4)
  1603.             if (noextflag)
  1604.                 goto unknown;
  1605.             else
  1606.                 dcomplex_seen++;
  1607.         v->vardesc.varno = k;
  1608.         }
  1609.     else {
  1610.  unknown:
  1611.         dclerr("unknown intrinsic function", v);
  1612.         return;
  1613.         }
  1614.     if(v->vstg == STGUNKNOWN)
  1615.         v->vstg = STGINTR;
  1616.     else if(v->vstg!=STGINTR)
  1617.         dclerr("incompatible use of intrinsic function", v);
  1618.     if(v->vclass==CLUNKNOWN)
  1619.         v->vclass = CLPROC;
  1620.     if(v->vprocclass == PUNKNOWN)
  1621.         v->vprocclass = PINTRINSIC;
  1622.     else if(v->vprocclass != PINTRINSIC)
  1623.         dclerr("invalid intrinsic declaration", v);
  1624. }
  1625.  
  1626.  
  1627.  
  1628. /* setext -- Set External declaration -- assume that unknowns will become
  1629.    procedures */
  1630.  
  1631.  void
  1632. #ifdef KR_headers
  1633. setext(v)
  1634.     register Namep v;
  1635. #else
  1636. setext(register Namep v)
  1637. #endif
  1638. {
  1639.     if(v->vclass == CLUNKNOWN)
  1640.         v->vclass = CLPROC;
  1641.     else if(v->vclass != CLPROC)
  1642.         dclerr("invalid external declaration", v);
  1643.  
  1644.     if(v->vprocclass == PUNKNOWN)
  1645.         v->vprocclass = PEXTERNAL;
  1646.     else if(v->vprocclass != PEXTERNAL)
  1647.         dclerr("invalid external declaration", v);
  1648. } /* setext */
  1649.  
  1650.  
  1651.  
  1652.  
  1653. /* create dimensions block for array variable */
  1654.  
  1655.  void
  1656. #ifdef KR_headers
  1657. setbound(v, nd, dims)
  1658.     register Namep v;
  1659.     int nd;
  1660.     struct Dims *dims;
  1661. #else
  1662. setbound(register Namep v, int nd, struct Dims *dims)
  1663. #endif
  1664. {
  1665.     register expptr q, t;
  1666.     register struct Dimblock *p;
  1667.     int i;
  1668.     extern chainp new_vars;
  1669.     char buf[256];
  1670.  
  1671.     if(v->vclass == CLUNKNOWN)
  1672.         v->vclass = CLVAR;
  1673.     else if(v->vclass != CLVAR)
  1674.     {
  1675.         dclerr("only variables may be arrays", v);
  1676.         return;
  1677.     }
  1678.  
  1679.     v->vdim = p = (struct Dimblock *)
  1680.         ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) );
  1681.     p->ndim = nd--;
  1682.     p->nelt = ICON(1);
  1683.     doin_setbound = 1;
  1684.  
  1685.     if (noextflag)
  1686.         for(i = 0; i <= nd; i++)
  1687.             if (((q = dims[i].lb) && !ISINT(q->headblock.vtype))
  1688.              || ((q = dims[i].ub) && !ISINT(q->headblock.vtype))) {
  1689.                 sprintf(buf, "dimension %d of %s is not an integer.",
  1690.                     i+1, v->fvarname);
  1691.                 errext(buf);
  1692.                 break;
  1693.                 }
  1694.  
  1695.     for(i = 0; i <= nd; i++) {
  1696.         if (((q = dims[i].lb) && !ISINT(q->headblock.vtype)))
  1697.             dims[i].lb = mkconv(TYINT, q);
  1698.         if (((q = dims[i].ub) && !ISINT(q->headblock.vtype)))
  1699.             dims[i].ub = mkconv(TYINT, q);
  1700.         }
  1701.  
  1702.     for(i = 0; i <= nd; ++i)
  1703.     {
  1704.         if( (q = dims[i].ub) == NULL)
  1705.         {
  1706.             if(i == nd)
  1707.             {
  1708.                 frexpr(p->nelt);
  1709.                 p->nelt = NULL;
  1710.             }
  1711.             else
  1712.                 err("only last bound may be asterisk");
  1713.             p->dims[i].dimsize = ICON(1);
  1714.             p->dims[i].dimexpr = NULL;
  1715.         }
  1716.         else
  1717.         {
  1718.  
  1719.             if(dims[i].lb)
  1720.             {
  1721.                 q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
  1722.                 q = mkexpr(OPPLUS, q, ICON(1) );
  1723.             }
  1724.             if( ISCONST(q) )
  1725.             {
  1726.                 p->dims[i].dimsize = q;
  1727.                 p->dims[i].dimexpr = (expptr) PNULL;
  1728.             }
  1729.             else {
  1730.                 sprintf(buf, " %s_dim%d", v->fvarname, i+1);
  1731.                 p->dims[i].dimsize = (expptr)
  1732.                     autovar(1, tyint, EXNULL, buf);
  1733.                 p->dims[i].dimexpr = q;
  1734.                 if (i == nd)
  1735.                     v->vlastdim = new_vars;
  1736.                 v->vdimfinish = 1;
  1737.             }
  1738.             if(p->nelt)
  1739.                 p->nelt = mkexpr(OPSTAR, p->nelt,
  1740.                     cpexpr(p->dims[i].dimsize) );
  1741.         }
  1742.     }
  1743.  
  1744.     q = dims[nd].lb;
  1745.     if(q == NULL)
  1746.         q = ICON(1);
  1747.  
  1748.     for(i = nd-1 ; i>=0 ; --i)
  1749.     {
  1750.         t = dims[i].lb;
  1751.         if(t == NULL)
  1752.             t = ICON(1);
  1753.         if(p->dims[i].dimsize)
  1754.             q = mkexpr(OPPLUS, t,
  1755.                 mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q));
  1756.     }
  1757.  
  1758.     if( ISCONST(q) )
  1759.     {
  1760.         p->baseoffset = q;
  1761.         p->basexpr = NULL;
  1762.     }
  1763.     else
  1764.     {
  1765.         sprintf(buf, " %s_offset", v->fvarname);
  1766.         p->baseoffset = (expptr) autovar(1, tyint, EXNULL, buf);
  1767.         p->basexpr = q;
  1768.         v->vdimfinish = 1;
  1769.     }
  1770.     doin_setbound = 0;
  1771. }
  1772.  
  1773.  
  1774.  void
  1775. #ifdef KR_headers
  1776. wr_abbrevs(outfile, function_head, vars)
  1777.     FILE *outfile;
  1778.     int function_head;
  1779.     chainp vars;
  1780. #else
  1781. wr_abbrevs(FILE *outfile, int function_head, chainp vars)
  1782. #endif
  1783. {
  1784.     for (; vars; vars = vars -> nextp) {
  1785.     Namep name = (Namep) vars -> datap;
  1786.     if (!name->visused)
  1787.         continue;
  1788.  
  1789.     if (function_head)
  1790.         nice_printf (outfile, "#define ");
  1791.     else
  1792.         nice_printf (outfile, "#undef ");
  1793.     out_name (outfile, name);
  1794.  
  1795.     if (function_head) {
  1796.         Extsym *comm = &extsymtab[name -> vardesc.varno];
  1797.  
  1798.         nice_printf (outfile, " (");
  1799.         extern_out (outfile, comm);
  1800.         nice_printf (outfile, "%d.", comm->curno);
  1801.         nice_printf (outfile, "%s)", name->cvarname);
  1802.     } /* if function_head */
  1803.     nice_printf (outfile, "\n");
  1804.     } /* for */
  1805. } /* wr_abbrevs */
  1806.